home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / Floats / float.double next >
Encoding:
Text File  |  1992-04-28  |  37.1 KB  |  1,245 lines
  1. \ JFVGFP.DIEEE  Revised: 1/29/89   Length 15,580 bytes with max-inline=16
  2. \
  3. \ A double precision IEEE floating point JForth implementation
  4. \  of the Forth Vendors Group Floating Point Extension
  5. \  Dr. Dobb's Journal September 1984.
  6. \
  7. \ Copyright 1987 by
  8. \            David J. Sirag,
  9. \            17215 S. Harvest Ave.,
  10. \            Cerritos, CA 90701.
  11. \  Permission is hereby granted to distribute this code with JFORTH
  12. \  with the provision that this copyright notice and permission
  13. \  statement are included with the code.  It may be used by licensed
  14. \  users of JFORTH with the same restrictions as if it were part of
  15. \  JFORTH.
  16. \
  17. \ >>>>>>>>>>>>>>>
  18. \ Modifications by Phil Burk & Mike Haas, Delta Research, 8/15/88
  19. \ Some modifications were needed to take advantage
  20. \ of some of JForth 2.0's new features, ie. Clone,
  21. \ Precompiled Assembler Module and Hashing.
  22. \ References to Status Register changed to use GetCC exec call.
  23. \
  24. \ MOD: PLB 7/10/89 Changed SWIVEL2 to SWAP in INT.
  25. \                  Set FPWARN to TRUE instead of 1 for AND
  26. \ MOD: PLB 9/19/89 Fixed F#BYTES, Fixed NEG check in F**.
  27. \ MOD: PLB 4/24/90 Don't call SMUDGE0123
  28. \ MOD: PLB 6/5/90 Removed CRs from FLN and FLOG
  29. \ MOD: PLB 7/31/90 FIX converted to high level to eliminate bug
  30. \ MOD: PLB 8/31/90 Added check to FLOAT for very large neg numbers.
  31. \ 00001 PLB 9/21/91 Put ABORTs after FP INFINITY warnings, cleanup
  32. \ 00002 PLB 9/23/91 Trap FPEXP>1023 in F>TEXTs, return "Infinity"s
  33. \ 00003 PLB 1/4/92 Added FLOAT.NUMBER? FASTFP.NUMBER? FNUMBER?
  34. \ 00004 PLB 2/25/92 Fixed AUTO.TERM which used to call AUTO.INIT
  35. \ 00005 PLB 4/28/92 Fixed large negative numbers >F and UNPACK
  36.  
  37. \ <<<<<<<<<<<<<<<
  38. \
  39. \ Arithmetic operators:
  40. \  F+  F-  F*  F/  FABS  FNEGATE  FMAX  FMIN  F2*  F2/
  41. \
  42. \ Transcendental functions:
  43. \  FLOG   FLN    FSIN    FCOS    FTAN     FSINH   FCOSH   FTANH
  44. \  FALOG  FALN   FASIN   FACOS   FATAN    FSQRT   F**
  45. \  FCS    FATCS  DEG>RAD RAD>DEG DEG/RAD  PI      PI/2    2PI
  46. \
  47. \ Logical operators:
  48. \  F0=   F0<   F0>    F=    F<    F>
  49. \  F0<>  F0<=  F0>=   F<=   F>=   F<>
  50. \  FEQ   FLT   FGT    FNE   FLE   FGE   FVS   FVC
  51. \
  52. \ Stack operators:
  53. \  FDROP   FDUP    FOVER   FSWAP   FROT
  54. \  F>R     FR>     FR@     FRDROP
  55. \  FNOVER  NFOVER  FNSWAP  NFSWAP
  56. \  FFNROT  FNFROT  NFFROT  FNNROT  NFNROT  NNFROT
  57. \  FCELL   FCELL+  FCELL-  FCELLS  FCELL/  FCELLU/
  58. \
  59. \ Number handling operators:
  60. \  FLOAT  FIX (rounded)  INT (truncated)
  61. \  F!  F@  FCONSTANT  FVARIABLE  FARRAY
  62. \  FNUMBER  PACK  UNPACK  F#BYTES  F#PLACES
  63. \
  64. \ Display operators:
  65. \  F.   E.   ENG.   PLACES (sets FFLD described below)
  66. \  F.R  E.R  ENG.R  (display rounded and right justified in field)
  67. \  F>TEXT  F>ETEXT  F>ENGTEXT ( create f., e., and eng. strings )
  68. \
  69. \ Display operators & variables - not in FVG84:
  70. \  FLD         - total width of field for number displays
  71. \  FFLD        - width of fractional field for F. - places after decimal
  72. \  EFFLD       - width of fractional field for E. and ENG.
  73. \  F.EXMAX     - maximum exponent for decimal form display for F.
  74. \  F.ENDPOINT  - flag indicating whether to use a point at end of F. display
  75. \  DP-CHARS    - symbols for decimal point and comma - allows Euro style
  76. \  E.PLUS      - flag for "E+01" rather than "E01" - aligns with "E-01"
  77. \  EXPSYMBOL   - symbol for "E" for E. and ENG. - allows upper or lower "E"
  78. \  COMMAS      - use commas (from Jforth) in F. and integer displays
  79. \  NO-COMMAS   - don't use commas in F. and integer displays
  80. \  FPWARN      - flag to display floating point warning messages
  81. \
  82. \ Number interpreters - fp only interpreted if base is 10 - not in FVG84:
  83. \  FLOAT.INTERPRET  - integers, decimal form and "E" form real numbers
  84. \  FASTFP.INTERPRET - integers and decimal form real numbers
  85. \  FIX.INTERPRET    - integers
  86. \  NTYPE            - number type variable  1 = int, 2 = fp, 0 = not number
  87. \
  88. \ Significant digits:
  89. \  The fp number interpreters and fp diplay routines provide
  90. \  15 significant digit conversions to and from floating point.
  91. \  For example, 1.234567890123456 F. will display 1.23456789012346.
  92. \  The transendental functions use the ffp library; thus, they are
  93. \  accurate to about 7 significant digits.
  94.  
  95. only forth definitions
  96.  
  97. ANEW FP-DEFINITIONS
  98.  
  99. : DIEEE ;
  100.  
  101. : OPEN-MATHLIBS ( --- )
  102.     mathieeedoubbas? mathieeedoubtrans? mathtrans? ;
  103. : CLOSE-MATHLIBS ( --- )
  104.     -mathieeedoubbas -mathieeedoubtrans -mathtrans ;
  105. ." Opening Math Libraries" cr
  106. open-mathlibs  decimal
  107.  
  108. \ Stack and memory operators  ==FVG84 required (except as noted)
  109. \  Even when these operators are identical to an integer equivalent,
  110. \  the fp form of the operator should be used in application code so
  111. \  that the application will function properly when a floating point
  112. \  inplementation with a different number of bytes is substituted.
  113.  
  114. : F!    2!    both ;
  115. : F@    2@    both ;
  116. : FDROP 2drop both ;
  117. : FDUP  2dup  both ;
  118. : FOVER 2over both ;
  119. : FSWAP 2swap both ;
  120.  
  121. code FROT   dsp a@+  0dr dn  move    dsp a@+  1dr dn  move
  122.     dsp a@+  2dr dn  move    dsp a@+  3dr dn  move
  123.     dsp a@   4dr dn  move    2dr dn   dsp a@  move
  124.     1dr dn   dsp -a@ move    0dr dn   dsp -a@ move
  125.     tos dn   dsp -a@ move    4dr dn   dsp -a@ move
  126.     3dr dn   tos dn  move
  127.     rts      end-code
  128.  
  129. \ return stack operators  ==extensions to FVG84
  130.  
  131. code F>R     dsp a@+ rp  -a@  move    tos dn  rp -a@  move
  132.     dsp a@+ tos dn   move    both  rts end-code
  133.  
  134. code FR>     tos dn  dsp -a@  move    rp a@+  tos dn  move
  135.     rp  a@+ dsp -a@  move    both  rts end-code
  136.  
  137. code FR@     tos dn  dsp -a@  move    rp a@   tos dn  move
  138.     rp 4 an+w dsp -a@ move   both  rts end-code
  139.  
  140. code FRDROP  8 #  rp an  addq         both  rts end-code
  141.  
  142.  
  143. \ fixed number type stack operators  ==extensions to FVG84
  144.  
  145. code FNOVER ( r n --- r n r )
  146.     tos dn  dsp -a@  move    dsp 4 an+w tos dn  move
  147.     dsp 8 an+w dsp -a@  move
  148.     both  rts  end-code
  149.  
  150. code NFOVER ( n r --- n r n )
  151.     tos dn  dsp -a@  move    dsp 8 an+w tos dn  move
  152.     both    rts      end-code
  153.  
  154. : FNSWAP ( r n --- n r ) -rot both ;
  155.  
  156. : NFSWAP ( n r --- r n )  rot both ;
  157.  
  158. code FFNROT ( r1 r2 n --- r2 n r1 )
  159.     tos dn  1dr dn  move
  160.     dsp a@+ 2dr 3dr 4dr tos  movem
  161.     tos dn  0dr dn  move
  162.     4dr dn  tos dn  move
  163.     0dr 1dr 2dr 3dr dsp -a@  movem
  164.     both  rts  end-code
  165.  
  166. : FNFROT ( r1 n r2 --- n r2 r1 ) ffnrot ;
  167.  
  168. code NFFROT ( n r1 r2 --- r1 r2 n )
  169.     tos dn  0dr dn  move
  170.     dsp a@+  1dr 2dr 3dr tos  movem
  171.     0dr 1dr 2dr 3dr  dsp -a@  movem
  172.     both  rts  end-code
  173.  
  174. : FNNROT ( r n1 n2 --- n1 n2 r ) 2swap both ;
  175.  
  176. code NFNROT ( n1 r n2 --- r n2 n1 )
  177.     tos dn  0dr dn  move
  178.     dsp a@+ 1dr 2dr tos  movem
  179.     0dr 1dr 2dr dsp -a@  movem
  180.     both  rts  end-code
  181.  
  182. : NNFROT ( n1 n2 r --- n2 r n1 ) nfnrot both ;
  183.  
  184.  
  185. \ Fp cell operators  ==extensions to FVG84
  186.  
  187. code FCELL+  ( n --- n )  8 #  tos dn  addq  both   rts   end-code
  188. code FCELL-  ( n --- n )  8 #  tos dn  subq  both   rts   end-code
  189. code FCELLS  ( n --- n )  3 #  tos dn  lsl   both   rts   end-code
  190. code FCELL/  ( n --- n )  3 #  tos dn  lsr   both   rts   end-code
  191. code FCELLU/ ( n --- n )  3 #  tos dn  lsr   both   rts   end-code
  192.  
  193. : FVARIABLE create 0 , 0 ,   does> ;
  194.  
  195. : FCONSTANT create , ,       does>  f@ ;
  196.  
  197. : FARRAY  \ fp array with size error checking   == extension to FVG84
  198.     create dup , 0 do -1 , -1 , loop
  199.     does>  [ also assembler
  200.         dsp a@  0dr dn  move
  201.         1dr dn  clr
  202.         org tos 0 an+r+b  0dr dn  cmp
  203.         1dr dn  byte   scc
  204.         3 #     0dr dn  asl
  205.         0dr dn  tos dn  add
  206.         4 #     tos dn  addq
  207.         tos dn  dsp a@  move
  208.         1dr dn  tos dn  move
  209.     previous ] if ."  farray size" 0 error then ;
  210.  
  211. 8        constant  FCELL       \ number of bytes required for fp
  212. -1 -1    fconstant F-INFINITY  \ internal use
  213. -1 $ 7fffffff fconstant FINFINITY   \ internal use
  214. $ 20000  constant  FPOV        \ internal use
  215.     variable  FPWARN      \ if true, fp warning messages will display
  216. \ 1 fpwarn !  \ ==extension to FVG84
  217. TRUE fpwarn !  \ ==extension to FVG84  ( use TRUE for AND )
  218.     variable  FPSTAT      \ status of last fp operation
  219. \ bit flags (hex) 20000 = overflow
  220. \ 40000 = zero    80000 = negative
  221. \ other bits are undefined ==FVG84 optional
  222.  
  223.  
  224. : FPCEND ( -- , compile extend )
  225.     compile b->s
  226. ;
  227. code (@>CCR) ( cc -- cc , copy codes to ccr )
  228.     org 7dr 0  an+r+b   move-to-ccr
  229.     inline rts
  230. end-code
  231.  
  232. \ These macros must compile BSR references to FPSTAT
  233. \ for proper cloning.
  234. : FPSTAT->CCR \ macro: move fp status to cond code reg
  235.     compile fpstat
  236.     compile (@>ccr)
  237. ;
  238.  
  239.  
  240. \ Fp logical operators that test the fpstat condition code of the last
  241. \ fp operation.  This allows very fast tests.  The resulting test flag
  242. \ is placed on the stack.  They do not set the condition codes in fpstat.
  243. \ Fvs and fvc test the overflow bit for being set or clear.
  244. \ ==extensions to FVG84
  245.  
  246. code FEQ ( --- f ) fpstat->ccr  tos dn byte seq  fpcend  both rts end-code
  247. code FLT ( --- f ) fpstat->ccr  tos dn byte slt  fpcend  both rts end-code
  248. code FGT ( --- f ) fpstat->ccr  tos dn byte sgt  fpcend  both rts end-code
  249. code FNE ( --- f ) fpstat->ccr  tos dn byte sne  fpcend  both rts end-code
  250. code FLE ( --- f ) fpstat->ccr  tos dn byte sle  fpcend  both rts end-code
  251. code FGE ( --- f ) fpstat->ccr  tos dn byte sge  fpcend  both rts end-code
  252. code FVS ( --- f ) fpstat->ccr  tos dn byte svs  fpcend  both rts end-code
  253. code FVC ( --- f ) fpstat->ccr  tos dn byte svc  fpcend  both rts end-code
  254.  
  255. ASM SWIVEL2 ( a b c d -- b a d c )
  256.     move.l    (dsp),D0
  257.     move.l    tos,(dsp)
  258.     move.l    d0,tos
  259.     move.l    $8(dsp),D0
  260.     move.l    $4(dsp),$8(dsp)
  261.     move.l    d0,$4(dsp)
  262.     rts
  263. end-code
  264.  
  265.  
  266. \ Fp logical operators that compare two fp numbers on the stack.
  267. \ The two numbers are removed from the stack and replaced with
  268. \ the resulting test flag.  They do not set the condition codes
  269. \ in fpstat.   ==FVG84 required (except as noted)
  270.  
  271. \ Make macro using both
  272. code (FPC)
  273.     ] swivel2 ret:sr callvoid mathieeedoubbas_lib IEEEDPCmp [
  274.     tos dn move-to-ccr
  275. end-code
  276.  
  277. : FPC compile (FPC) ;
  278.  
  279. code F=  ( r1 r2 --- f ) fpc  tos dn byte seq  fpcend  both  rts  end-code
  280. code F<  ( r1 r2 --- f ) fpc  tos dn byte slt  fpcend  both  rts  end-code
  281. code F>  ( r1 r2 --- f ) fpc  tos dn byte sgt  fpcend  both  rts  end-code
  282.     \ following are ==FVG84 extensions
  283. code F<> ( r1 r2 --- f ) fpc  tos dn byte sne  fpcend  both  rts  end-code
  284. code F<= ( r1 r2 --- f ) fpc  tos dn byte sle  fpcend  both  rts  end-code
  285. code F>= ( r1 r2 --- f ) fpc  tos dn byte sge  fpcend  both  rts  end-code
  286.  
  287. \ Fp logical operators that test the number on the top of the stack.
  288. \ The number is replaced on the stack with the test result flag.
  289. \ They do not set the condition codes in fpstat.
  290. \ ==FVG84 required (except as noted)
  291.  
  292. code F0=  ( r --- f )
  293.     dsp a@+ tst
  294.     1 #     tos dn  lsl
  295.     tos dn  byte    seq   fpcend
  296.     both    rts     end-code
  297.  
  298. code F0<  ( r --- f )
  299.     dsp a@+ tst
  300.     31 #  tos dn  bclr  1 beq
  301.     tos dn  tst
  302. 1 br: tos dn  byte    sne   fpcend
  303.     both    rts     end-code
  304.  
  305. code F0>  ( r --- f )
  306.     dsp a@+ tst
  307.     1 #     tos dn  lsl
  308.     tos dn  byte    shi   fpcend
  309.     both    rts     end-code
  310.  
  311. code F0<> ( r --- f )
  312.     dsp a@+ tst                 \ ==extension to FVG84
  313.     1 #     tos dn  lsl
  314.     tos dn  byte    sne   fpcend
  315.     both    rts     end-code
  316.  
  317. code F0<= ( r --- f )
  318.     dsp a@+ tst                  \ ==extension to FVG84
  319.     1 #     tos dn  lsl
  320.     tos dn  byte    sls   fpcend
  321.     both    rts     end-code
  322.  
  323. code F0>= ( r --- f )
  324.     dsp a@+ tst                  \ ==extension to FVG84
  325.     31 #    tos dn  bclr  1 beq
  326.     tos dn  tst
  327.     1 br: tos dn  byte    seq   fpcend
  328.     both    rts     end-code
  329.  
  330. \ Fp arithmetic operators   ==FVG84 required (except as noted)
  331. \ Fpstat condition codes are set by arithmetic operators
  332.  
  333. : F+ ( r1 r2 --- r )
  334.     swivel2 ret:sr dcall mathieeedoubbas_lib IEEEDPAdd fpstat w! swap
  335. ;
  336.  
  337. : F- ( r1 r2 --- r )
  338.     swivel2 ret:sr dcall mathieeedoubbas_lib IEEEDPSub fpstat w! swap
  339. ;
  340.  
  341. : F* ( r1 r2 --- r )
  342.     swivel2 ret:sr dcall mathieeedoubbas_lib IEEEDPMul fpstat w! swap
  343. ;
  344.  
  345. : F/ ( r1 r2 --- r )
  346.     2dup f0= abort" F/ - Divide by zero!"
  347.     swivel2 ret:sr dcall mathieeedoubbas_lib IEEEDPDiv fpstat w! swap
  348. ;
  349.  
  350. code TEST.NZ  ( N -- N ccr )
  351.     tos dn  dsp -a@ move
  352.     tos dn  tst   9 beq
  353.     tos dn  byte tst
  354. 9 br: \ 7dr dn  move-from-sr
  355.     4 abs.l  0ar an  move
  356.     0ar $ -210 an+w jsr
  357.     0 # tos dn moveq
  358.     0dr dn tos dn word move
  359. both
  360. rts
  361. end-code
  362.  
  363. : SET-FPSTAT  \ macro: test tos, set n & z in fpstat
  364.     compile test.nz
  365.     compile fpstat
  366.     compile w!
  367. ;
  368.  
  369. code CC2D0   ( get the cc, put in d0, wrecks a0 also )
  370.     4 abs.w  0ar an  move
  371.     0ar $ -210 an+w jsr
  372. both end-code
  373.  
  374. code F2*   ( r --- r )
  375.     tos dn  1dr dn  move
  376.     $ 100000 #  tos dn  add
  377.     set-fpstat
  378.     tos dn  1dr dn  eor   1dr dn  tst  1 bge
  379.     $ 100000 #   tos dn  sub   -1 #  dsp a@  move
  380.     $ 7fffffff # tos dn  or
  381. \    2 #  byte ori-ccr
  382. \    org 4dr 0 an+r+b  move-from-sr
  383.         ] cc2d0 [
  384.         2 #  0dr dn  word or
  385.         ] fpstat [
  386.         0dr dn   org tos 0 an+r+b  word move
  387.         dsp a@+  tos dn   move
  388. 1 br: rts     end-code
  389.  
  390. code F2/   ( r --- r )
  391.     tos dn  1dr dn  move
  392.     $ 100000 #   tos dn  sub
  393.     set-fpstat
  394.     tos dn  1dr dn  eor   1dr dn  tst  1 bge
  395.     tos dn  clr           dsp a@  clr
  396.         ] cc2d0 fpstat [
  397.         0dr dn   org tos 0 an+r+b  word move
  398.         4 #  dsp an  addq
  399.         tos dn  clr
  400. 1 br: rts     end-code
  401.  
  402. code FABS  ( r --- r )
  403.     $ 7fffffff #  tos dn and
  404.     set-fpstat
  405.     both    rts   end-code
  406.  
  407. code FNEGATE ( r --- r )
  408.     fpstat #    4dr dn move   \ change sign
  409.     tos dn tst  1 beq
  410.     $ 80000000 #  tos dn eor
  411. 1 br:  set-fpstat
  412.     both    rts   end-code
  413.  
  414. code FMAX  ( r1 r2 --- r )
  415.     dsp a@+  0dr 1dr 2dr  movem
  416.     1dr dn  3dr dn   move    2dr dn  4dr dn  move
  417.     tos dn  0ar an   move    0dr dn  1ar an  move
  418.     31 #    1dr dn   bclr    1 beq
  419.     2dr dn  neg      1dr dn  negx
  420. 1 br: 31 #    tos dn   bclr    2 beq
  421.     0dr dn  neg      tos dn  negx
  422. 2 br: 0dr dn  2dr dn   sub    \ fpstat # 0dr dn  move
  423.     tos dn  1dr dn   subx    3 blt
  424.     4dr dn  dsp -a@  move    3dr dn  tos dn  move    4 bra
  425. 3 br: 1ar an  dsp -a@  move    0ar an  tos dn  move
  426. 4 br: set-fpstat
  427.     both    rts      end-code
  428.  
  429. code FMIN  ( r1 r2 --- r )
  430.     dsp a@+  0dr 1dr 2dr  movem
  431.     1dr dn  3dr dn   move    2dr dn  4dr dn  move
  432.     tos dn  0ar an   move    0dr dn  1ar an  move
  433.     31 #    1dr dn   bclr    1 beq
  434.     2dr dn  neg      1dr dn  negx
  435. 1 br: 31 #    tos dn   bclr    2 beq
  436.     0dr dn  neg      tos dn  negx
  437. 2 br: 0dr dn  2dr dn   sub     \ fpstat # 0dr dn  move
  438.     tos dn  1dr dn   subx    3 bgt
  439.     4dr dn  dsp -a@  move    3dr dn  tos dn  move    4 bra
  440. 3 br: 1ar an  dsp -a@  move    0ar an  tos dn  move
  441. 4 br: set-fpstat
  442.     both    rts      end-code
  443.  
  444.  
  445. \ Fp conversion routines  ==FVG84 required (except as noted)
  446. \ Fpstat condition codes are set by conversion routines
  447.  
  448. : (FLOAT)   ( n --- r )        \ for internal use
  449.     ret:sr dcall mathieeedoubbas_lib IEEEDPFlt fpstat w! swap
  450. ;
  451.  
  452. code $200000/mod                  \ for internal use
  453.     tos dn  0dr dn  move    3dr dn  byte    slt
  454.     3dr dn  word    ext     3dr dn          ext
  455.     dsp a@  1dr dn  move    1dr dn  2dr dn  move
  456.     $ ffe00000 # 3dr dn and $ 1fffff #  2dr dn and
  457.     3dr dn  2dr dn  or      2dr dn  dsp a@  move
  458.     21 #    4dr dn  move    4dr dn  tos dn  asr
  459.     4dr dn  1dr dn  lsr     11 #    4dr dn  move
  460.     4dr dn  0dr dn  lsl     1dr dn  0dr dn  or
  461.     0dr dn  dsp -a@ move    rts     end-code
  462.  
  463. : FLOAT  ( n --- r )                  \ Convert integer to fp
  464.     dup abs $ 200000 >
  465.     IF  dup 0<   \ This doesn't seem to handle negative
  466.         IF negate true   \ so convert it to positive first.
  467.         ELSE false
  468.         THEN swap
  469.         s->d       \  assumes that (float) can handle
  470.         $200000/mod drop (float)      \  21 bits accurately
  471.         $ 1500000 + nfswap (float) f+
  472.         nfswap
  473.         IF fnegate
  474.         THEN
  475.     ELSE (float)
  476.     THEN ;
  477.  
  478. : INT     ( r --- n )                  \ truncate and convert to integer
  479. \   swivel2 ret:sr call mathieeedoubbas_lib IEEEDPFix dup fpstat w!
  480. \    fpov and
  481. \    fpwarn @ AND
  482. \    IF ." ...warning fp too large for int" cr
  483. \    THEN
  484. \ Use SWAP instead of SWIVEL2 because only one argument.
  485. \ Don't check for overflow because of false alarms for negative numbers.
  486.     SWAP call mathieeedoubbas_lib IEEEDPFix
  487. ;
  488.  
  489. 1         float  fconstant  F1
  490. 100000000 float  fconstant  F100000000
  491. f1 f100000000 f/ fconstant  F.00000001
  492.  
  493. : FIX ( r -- i , round then integerize )
  494.     fdup f0>
  495.     IF [ f1 f2/ ] dliteral
  496.     ELSE [ f1 f2/ fnegate ] dliteral
  497.     THEN
  498.     f+ INT
  499. ;
  500.  
  501. \ Fp transendental functions.  Fpstat condition codes are set by these
  502. \ functions.   ==FVG84 required or optional (except as noted).
  503. \ They are based on the ffp library; thus, they are accurate to about
  504. \ 7 significant digits.
  505. \ If transcendental functions are wanted (or not wanted)
  506. \ place true (or false) prior to the .if on the next line
  507. \ The transendental functions use about 2000 bytes.
  508.  
  509. true .if
  510.  
  511. 4614256656552045848. fconstant PI
  512. pi   $ 100000 -      fconstant PI/2    \ ==extension to FVG84
  513. pi   $ 100000 +      fconstant 2PI     \ ==extension to FVG84
  514. 4633260481411531256. fconstant DEG/RAD \ ==extension to FVG84
  515.  
  516. code DIEEE->FFP ( r.dieee --- r.ffp ) \ convert double ieee fp to ffp fp
  517.     tos dn  0dr dn  move     dsp a@+ 1dr dn  move \ internal use
  518.     8 #     tos dn  rol      4 #     tos dn  rol
  519.     tos dn  2dr dn  move     $ 7ff # tos dn  and
  520.     $ -1000 # 2dr dn and     1 #     2dr dn  lsr
  521.     31 #    2dr dn  bset     1dr dn  swap
  522.     5 # 1dr dn word lsr      1dr dn  ext
  523.     1dr dn  2dr dn  or
  524.     $ 80 #  2dr dn  add      1 bcc
  525.     1 #     2dr dn  roxr     1 #     tos dn  addq
  526. 1 br: $ -100 # 2dr dn and
  527.     958 #   tos dn  sub      2 bgt
  528.     tos dn  clr   2dr dn  clr   0dr dn  clr
  529. 2 br: $ 7f  # tos dn  cmp      3 ble
  530.     $ 7f  # tos dn  move     $ ffffff00 # 2dr dn move
  531. 3 br: 0dr dn  tst     4 bpl    7 #     tos dn  bset
  532. 4 br: 2dr dn  tos dn  or       rts     end-code
  533.  
  534. code FFP->DIEEE ( r.ffp --- r.dieee ) \ convert ffp fp to double ieee
  535.     tos dn  0dr dn  move     3 beq   \ for internal use
  536.     7 #     tos dn  bclr
  537.     $ ffffff7f # tos dn cmp  1 bne
  538.     0dr dn  tos dn  move     8 #     tos dn  ror
  539.     7 #     0dr dn  bset     3 bra
  540. 1 br: $ 7f #  tos dn  and      958 #   tos dn  add
  541.     0dr dn  byte    tst      2 bpl
  542.     11 #    tos dn  bset
  543. 2 br: tos dn  swap             4 #     tos dn  lsl
  544.     0dr dn  swap             5 #     0dr dn  rol
  545.     0dr dn  1dr dn  move     $ fffff #    1dr dn  and
  546.     1dr dn  tos dn  or       $ e0000000 # 0dr dn  and
  547. 3 br: 0dr dn  dsp -a@ move     rts     end-code
  548.  
  549.  
  550. : F** ( r1 r2 --- r )
  551.     fover f0<
  552.     IF  fdrop fdrop 0 0
  553.         ." ...warning - power of negative number" cr
  554.     ELSE swivel2 2swap
  555.         ret:sr dcall mathieeedoubtrans_lib IEEEDPPow fpstat w! swap
  556.     THEN
  557. ;
  558.  
  559. : FSQRT   ( r --- r )
  560.     2dup f0< abort" Error - square root of negative number!"
  561.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPSqrt fpstat w! swap
  562. ;
  563.  
  564. : FLN   ( r --- r )
  565.     2dup f0<= abort" Error - ln of 0 or negative number "
  566.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPLog fpstat w! swap
  567. ;
  568. : FLOG   ( r --- r )
  569.     2dup f0<= abort" Error - log of 0 or negative number "
  570.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPLog10 fpstat w! swap
  571. ;
  572.  
  573. : FALOG ( r --- r )
  574.     0 $ 40240000  ( 10.0 ) 2swap f**
  575. ;
  576.  
  577. : FALN ( r --- r )
  578.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPExp fpstat w! swap
  579. ;
  580.  
  581.  
  582. : FSIN ( r.rad --- r )
  583.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPSin fpstat w! swap
  584. ;
  585.  
  586. : FCOS ( r.rad --- r )
  587.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPCos fpstat w! swap
  588. ;
  589.  
  590. : FTAN ( r.rad --- r )
  591.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPTan fpstat w! swap
  592. ;
  593.  
  594. : FASIN ( r --- r.rad )
  595.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPASin fpstat w! swap
  596. ;
  597.  
  598. : FACOS ( r --- r.rad )
  599.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPACos fpstat w! swap
  600. ;
  601.  
  602. : FATAN ( r --- r.rad )
  603.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPAtan fpstat w! swap
  604. ;
  605.  
  606. : FSINH ( r.rad --- r )
  607.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPSinh fpstat w! swap
  608. ;
  609.  
  610. : FCOSH ( r.rad --- r )
  611.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPCosh fpstat w! swap
  612. ;
  613.  
  614. : FTANH ( r.rad --- r )
  615.     swap ret:sr dcall mathieeedoubtrans_lib IEEEDPTanh fpstat w! swap
  616. ;
  617.  
  618. FVARIABLE FCS-PAD  ( holds result from sincos )
  619. : FCS   ( r.rad --- r.sin r.cos )            \ cosine & sine  - spsincos
  620.     swap fcs-pad >abs -rot
  621.     ret:sr  dcall mathieeedoubtrans_lib IEEEDPSinCos fpstat w!
  622.     swap fcs-pad F@
  623. ;
  624.  
  625. : FATCS  ( r.sin r.cos --- r.rad ) \ four quadrant atan - fortran's atan2
  626.     fdup f0< if -1 else 0 then >r \ ==extension to FVG84
  627.     fdup f0=
  628.     IF fdrop
  629.         f0>
  630.         IF pi/2
  631.         ELSE pi/2 fnegate
  632.         THEN
  633.     ELSE f/ fatan
  634.     THEN
  635.     r> if pi fover f0> if f- else f+ then then ;
  636.  
  637. : DEG>RAD deg/rad f/ ; \  convert degrees to radians   ==extension to FVG84
  638. : RAD>DEG deg/rad f* ; \  convert radians to degrees   ==extension to FVG84
  639.  
  640. \ end of transendental functions
  641. .then
  642.  
  643.  
  644. \ Fp ascii conversion and display routines.  Fpstat is not set by the ascii
  645. \ conversion and display routines.  Fpstat from a prior fp operation is not
  646. \ preserved through these routines.
  647. \ ==FVG84 required, optional, or extension is indicated with each routine.
  648.  
  649. variable FFLD    \ Fractional field - digits to display after decimal
  650. -1 ffld !        \  when displayed with f.  min=0 max=15 (-1=variable width)
  651. \ ==extension to FVG84
  652.  
  653. variable F.EXMAX \ Maximum exponent for which to use for decimal form
  654. 12 f.exmax !     \  when displayed with f. (larger exponents use e-form)
  655. \ ==extension to FVG84
  656.  
  657. variable F.ENDPOINT \ Flag indicating to put a point at the end
  658. -1 f.endpoint !     \ of a f. display when appropriate.
  659. \ 1 = point  0 = no point  ==extension to FVG84
  660.  
  661. variable EFFLD   \ fractional field in mantissa when displayed with e.
  662. 6 effld !        \  min = 0  max = 14 (no variable width feature)
  663. \ ==extenstion to FVG84
  664.  
  665. variable E.PLUS  \ true indicates to place "+" after "e" (e.g. "e+06")
  666. 1 e.plus !       \ ==extension to FVG84
  667.  
  668. variable EXPSYMBOL  \ contains ascii symbol for exponent in e form
  669. ascii e expsymbol ! \ ==extension to FVG84
  670.  
  671. \ 4 constant F#BYTES  \ number of bytes in a floating point number
  672. 8 constant F#BYTES  \ number of bytes in a floating point number
  673. \ ==FVG84 optional
  674.  
  675. 15 constant F#PLACES \ maximum number of significant digits in fp number
  676. \ ==FVG84 optional
  677.  
  678. variable DP-CHARS      \ double precision characters  ==FVG84 extension
  679. ascii . dp-chars w!    \ . is normal decimal point
  680. ascii , dp-chars 2+ w! \ , is normal digits separator
  681.  
  682. variable  SIGDIG      variable  UNPP2          \ for internal use
  683. fvariable UNPREAL     fvariable UNPMULT      variable UNPEX
  684. 40 farray FPEXP.ARY   40 farray -FPEXP.ARY
  685.  
  686.  
  687. redef? @  redef? off
  688. : xx f1 40 0 do fdup i fpexp.ary f! f100000000 f* loop fdrop ;
  689. xx
  690.  
  691. : yy f1 40 0 do fdup i -fpexp.ary f! f.00000001 f* loop fdrop ;
  692. yy
  693. forget xx
  694. redef? !
  695.  
  696. : DVARIABLE fvariable ; \ dvariables are necessary in conversion routines
  697.  
  698. code D0=       dsp a@+ tos dn  or   tos dn  byte seq
  699.     tos dn  word    ext  tos dn  ext
  700.     rts     end-code
  701.  
  702. : FLOATEXP  ( n --- n r ) \  convert int exp to fp power of 10
  703.     dup 0> if                \   factored to real and int power of 2
  704.         dup 309 < if          \  for internal use
  705.             8 /mod swap
  706.             0 1 rot ?dup if 0 do 5 * swap 1+ swap loop then
  707.             float nnfrot fpexp.ary f@ f*
  708.         else drop 0 finfinity
  709.             fpwarn @ if ." FLOATEXP ... warning fp infinity " abort then
  710.         then
  711.     else
  712.         dup -309 > if
  713.             abs 8 /mod swap
  714.             0 1 rot ?dup if abs 0 do 5 * swap 1- swap loop then
  715.             rot -fpexp.ary f@ nfswap float f/
  716.         else drop 0 0. then
  717.     then
  718. ;
  719.  
  720. : FPEXP ( r -- iexponent-binary )
  721.     swap drop $ 100000 / $ 7ff and $ 3fe -
  722. ; \ for internal use
  723. \ 1.23 fpexp = 1
  724.  
  725. code R*E16->D  ( r --- d ) \ convert fp * E16 to double int - internal use
  726.     tos dn   1dr dn  move    dsp a@  0dr dn  move
  727.     $ fffff # tos dn and     20 #    tos dn  bset
  728.     31 #     1dr dn  btst    1 beq
  729.     0dr dn   neg             tos dn  negx
  730. 1 br: $ 7ff00000 # 1dr dn and  1dr dn  swap
  731.     4 #     1dr dn lsr       1076 #  1dr dn  sub     3 blt
  732. 2 br: 1 #     0dr dn lsl       1 #     tos dn  roxl
  733.     1dr dn  2 word dbra
  734. 3 br: 0dr dn  dsp a@ move
  735.     rts     end-code
  736.  
  737. : >F ( d --- r ) \ converts a double integer with decimal to float
  738. \  uses position of decimal point indicated by dpl
  739. \  to position decimal point in floating point number
  740. \ modified by Rob Andre to fix large negative number problem 00005
  741.     ddup or
  742.     IF     \  max = 18 digits    ==extension to FVG84
  743.         dup 0<
  744.          >r
  745.         dabs
  746.         $200000/mod $200000/mod drop (float) $ 2a00000 +
  747.         nfswap (float) $ 1500000 + f+ nfswap (float) f+
  748.         dpl @ dup 0>
  749.         IF floatexp nfswap $ 100000 * + f/
  750.         ELSE drop
  751.         THEN
  752.         r>
  753.         IF fnegate
  754.         THEN
  755.     THEN
  756.     0 dpl !
  757. ;
  758.  
  759.  
  760. : UNPACK ( r --- d n )    \ float to d: mantissa 12345678901234567
  761. \  16 implied decimal places  n: exponent
  762. \  ==FVG84 optional
  763.     unpreal f!  f1 unpmult f!   0 unpex !   0 unpp2 !
  764.     unpreal f@ f0<>
  765.     IF
  766.  \ RGA mod -- use absolute value to find exponent 00005
  767.    unpreal f@ fdup fabs unpreal f!
  768.         BEGIN unpreal f@ unpmult f@ f/ fpexp  unpp2 @ -
  769.             0>
  770.         WHILE unpex @ 1+ dup unpex ! floatexp unpmult f! unpp2 !
  771.         REPEAT
  772. \
  773.         BEGIN unpreal f@ unpmult f@ f/ fpexp unpp2 @ - 1-
  774.             0<
  775.         WHILE unpex @ 1- dup unpex ! floatexp unpmult f! unpp2 !
  776.         REPEAT
  777. \
  778. \ RGA -- restore original floating point 00005
  779.    unpreal f!
  780.         unpreal f@ unpmult f@ f/ f1 unpp2 @ $ 100000 * - f*
  781.         f100000000 f* f100000000 f* r*e16->d
  782.         fpwarn @ if
  783.         unpex @ 307 >
  784.         IF ." UNPACK - ...warning fp infinity " abort then
  785.         THEN
  786.     ELSE 0.
  787.     THEN unpex @
  788. ;
  789.  
  790. : UNPKROUND ( d n1 n2 --- d n ) \ round unpacked num d,n1 to n2 sig dig
  791. \  n2 must be a number between 1 and 15
  792.     sigdig ! >r dup -rot dabs    \  for internal use
  793.     sigdig @ 8 <= if 100000000 m/ swap drop
  794.         5 8 sigdig @ - 0 do 10 * loop >r r@ +
  795.         r> dup + dup >r / r> *
  796.         dup 999999999 > if 10 / r> 1+ >r then
  797.         swap 0< if -1 * then 100000000 m*
  798.     else  100000000 m/ swap
  799.         5 16 sigdig @ - 0 do 10 * loop >r r@ +
  800.         r> dup + dup >r / r> *
  801.         dup 100000000 >= if 100000000 - swap 1+
  802.             dup 999999999 > if 10 / r> 1+ >r then swap
  803.         then swap 100000000 m* rot s->d d+
  804.         rot 0< if 0. dswap d- then
  805.     then r> ;
  806.  
  807. : PACK ( d n --- r )      \ d: signed double-integer mantissa
  808.     15 unpkround floatexp   \     with 16 implied decimal places
  809.     fnfrot >f               \ n: signed integer exponent
  810.     nffrot $ 100000 * +     \ r: number in double ieee form
  811.     f100000000 f/ f100000000 f/ f*
  812.     fpwarn @ if fvs if ." PACK - ... warning fp infinity " abort then
  813.     then ; \ ==FVG84 required
  814.  
  815.  
  816.  
  817. variable  E.CNT    variable E.EXCNT                \ for internal use
  818. dvariable F.MT     variable F.EX    dvariable F.MULT   variable F.CFLG
  819. variable  F.DIV    variable F.CH    variable  F.FFLD
  820.  
  821.  
  822. : (F>ETEXT) ( d n --- adr count ) \ internal use
  823.     effld @ 1+ unpkround
  824.     5 e.cnt !  (commas) @ >r no-commas
  825.     <# dup abs s->d # # ddup d0= not
  826.     IF # 1 e.cnt +!
  827.     THEN ddrop
  828.     0<
  829.     IF ascii - hold 1 e.cnt +!
  830.     else e.plus @ if ascii + hold 1 e.cnt +! then
  831.     then expsymbol @ hold
  832.     dup -rot dabs 16 effld @ - 0
  833.     DO # 1 hld +!
  834.     LOOP
  835.     effld @ ?dup if 0 do # loop then
  836.     effld @ e.cnt +!
  837.     dp-chars w@ hold # rot
  838.     0< if ascii - hold 1 e.cnt +! then
  839.     fld @ dup 0<
  840.     IF drop
  841.     ELSE e.cnt @ - 1- dup 0> if 0 do 32 hold loop else drop then
  842.     THEN
  843.     #> r> (commas) !
  844. ;
  845.  
  846. : F>ETEXT ( r --- addr count ) \ Converts fp to e-form text
  847. \ same as e. (below) but no printing
  848.     fdup FPEXP 1023 > \ 00002
  849.     IF
  850.         fdrop " Infinity" count
  851.     ELSE
  852.         unpack (f>etext)           \ ==extension to FVG84
  853.     THEN
  854. ;
  855.  
  856. : E. ( r1 --- ) \ display floating-point in exponential form
  857.     f>etext     \  uses the variable "fld" to indicate width of
  858.     type space  \   the display field (-1=variable width)
  859. ;
  860. \   if field is not wide enough for number,
  861. \    the number will be displayed overflowing the field
  862. \  uses the variable "effld" to indicate width of the
  863. \   mantissa fractional field (places after decimal point)
  864. \   (min = 0   max = 6)
  865. \  uses the variable "e.plus". if true a + is placed
  866. \   after the "e" so that e+06 and e-06 will line up.
  867. \  ==FVG84 required  with extended features
  868.  
  869. : E.R ( r n1 n2 --- )       \ e form display of floating point number
  870.     fld @ >r fld !        \ with n1 places to right of the decimal
  871.     effld @ >r            \ right justified in a field n2 characters wide.
  872.     dup 7 < over -1 > and \ ==FVG84 optional
  873.     not if drop r@ then effld !
  874.     e. r> effld ! r> fld ! ;
  875.  
  876.  
  877. : (F>ENGTEXT) ( r --- addr count ) \ Converts fp to eng-form text
  878. \ same as eng. (below) but no printing
  879.     (commas) @ >r no-commas       \ ==extension to FVG84
  880.     unpack effld @ 1+ unpkround
  881.     dup 3 mod dup 0< if 3 + then dup  e.excnt !  -
  882.     5 e.cnt !
  883.     <# dup abs s->d # # ddup d0= not if # then ddrop
  884.         0< if ascii - hold 1 e.cnt +!
  885.         else e.plus @ if ascii + hold 1 e.cnt +! then
  886.         then expsymbol @ hold
  887.         dup -rot dabs 16 effld @ - 0 do # 1 hld +! loop
  888.         effld @ e.excnt @ - ?dup if 0 do # loop then
  889.         effld @  e.cnt +!
  890.         dp-chars w@ hold
  891.         e.excnt @ 1+ 0 do # loop rot
  892.         0< if ascii - hold 1 e.cnt +! then
  893.         fld @ dup 0< if drop
  894.         else e.cnt @ - 1- dup 0> if 0 do 32 hold loop else drop then
  895.         then
  896.     #> r> (commas) ! ;
  897.  
  898. : F>ENGTEXT ( r --- addr count ) \ Converts fp to eng-form text
  899.     fdup FPEXP 1023 > \ 00002
  900.     IF
  901.         fdrop " Infinity" count
  902.     ELSE
  903.         (f>engtext)
  904.     THEN
  905. ;
  906.  
  907. : ENG. ( r1 --- ) \ display floating-point in engineering exponential form
  908.     f>engtext       \  with exponents ...,-06,-03,00,03,06,...
  909.     type space ;    \  uses the variable "fld" to indicate width of
  910. \   the display field (-1=variable width)
  911. \   if field is not wide enough for number,
  912. \    the number will be displayed overflowing the field
  913. \  uses the variable "effld" to indicate width of the
  914. \   mantissa display field. (effld + 1 = num sig dig)
  915. \   (effld min = 0,  effld max = 6)
  916. \  uses the variable "e.plus". if true a + is placed
  917. \   after the "e" so that e+06 and e-06 will line up.
  918. \ ==extension to FVG84
  919.  
  920.  
  921. : ENG.R ( r n1 n2 --- )  \ engineering form display of r with
  922.     fld @ >r fld !      \ with n1 + 1 significant digits
  923.     effld @ >r          \ right justified in a field n2 characters wide
  924.     dup 7 < over -1 > and \ ==extension of FVG84
  925.     not if drop r@ then effld !
  926.     eng. r> effld ! r> fld ! ;
  927.  
  928.  
  929. : -COMMA?      \ for internal use
  930.     (commas) @ if
  931.         f.cflg @ 1+ 3 mod dup f.cflg !
  932.         0= if dp-chars 2+ w@ 1 f.ch +! then
  933.     then ;
  934.  
  935. : +COMMA?      \ for internal use
  936.     (commas) @ if
  937.         f.cflg @ 1- 3 mod dup f.cflg !
  938.         0= if dp-chars 2+ w@ 1 f.ch +! then
  939.     then ;
  940.  
  941. code B->BCD      \ for internal use
  942.     dsp a@+ 1dr dn  move    16 #    3dr dn  move
  943. 1 br: 0dr dn  clr             1 #     2dr dn  move
  944. 2 br: tos dn  word swap       tos dn  0dr dn  word  move
  945.     10 # 0dr dn word divu   0dr dn  tos dn  word  move
  946.     2dr dn  2 word  dbra    1 #     2dr dn  move
  947. 3 br: 1dr dn  word swap       1dr dn  0dr dn  word  move
  948.     10 # 0dr dn word divu   0dr dn  1dr dn  word  move
  949.     2dr dn  3 word  dbra    0dr dn  word    swap
  950.     $ f #   0dr dn  and     0dr dn  dsp -a@ move
  951.     3dr dn  1 word  dbra    7 #     2dr dn  move
  952. 4 br: 4 #     tos dn  lsl     dsp a@+ tos dn  or
  953.     2dr dn  4 word  dbra    7 #     2dr dn  move
  954. 5 br: 4 #     1dr dn  lsl     dsp a@+ 1dr dn  or
  955.     2dr dn  5 word  dbra    1dr dn  dsp a@  move
  956.     rts     end-code
  957.  
  958. code (NEXTDIGIT) \ for internal use
  959.     4 #     tos dn  rol     tos dn  0dr dn  move
  960.     $ f #   tos dn  and     $ fffffff0 # 0dr dn  and
  961.     dsp a@  2dr dn  move    4 #     2dr dn  rol
  962.     2dr dn  3dr dn  move    $ fffffff0 # 2dr dn  and
  963.     $ f #   3dr dn  and     3dr dn  0dr dn  or
  964.     2dr dn  dsp a@  move    0dr dn  dsp -a@ move
  965.     rts     end-code
  966.  
  967. : NEXTDIGIT  ( --- c1 )      \ put next dig on stack
  968.     f.div @ 0> if           \ for internal use
  969.         f.mt d@ (nextdigit) fnswap f.mt d!
  970.         f.div @ 1- f.div !
  971.     else 0
  972.     then  ascii 0 +  1 f.ch +! ;
  973.  
  974. : F.-EX   \ used by f. when exp is <0
  975. \ for internal use
  976.     f.ffld @ 0= if ascii 0  dp-chars w@ 2 f.ch +!
  977.     else dp-chars w@ 1 f.ch +!  0 f.cflg !
  978.         f.ffld @ 0 do  1 f.ex +!
  979.             f.ex @ 0< if ascii 0  1 f.ch +!
  980.             else nextdigit then
  981.             f.mt d@ d0= ffld @ 0< and if leave
  982.             else f.ffld @ i 1+ > if -comma? then
  983.             then
  984.         loop
  985.     then ;
  986.  
  987. : F.+EX   \ used by f. when exp is 0>=
  988. \ for internal use
  989.     f.ex @ 1+ 0 do  nextdigit  +comma?  loop
  990.     (commas) @ if drop -1 f.ch +! then 0 f.cflg !
  991.     dp-chars w@ 1 f.ch +!
  992.     ffld @ 0< if
  993.         f.mt d@ d0= not if
  994.             f.ffld @ 0 do nextdigit
  995.                 f.mt d@ d0= if leave
  996.                 else f.ffld @ i 1+ > if -comma? then
  997.                 then
  998.             loop
  999.         then
  1000.     else
  1001.         ffld @ 0 do nextdigit loop
  1002.     then ;
  1003.  
  1004. : SET-F.FFLD ( --- )             \ Sets f.ffld - used by f>text
  1005.     ffld @ 0< if 15               \               for internal use
  1006.     else
  1007.         ffld @ 1+
  1008.         f.ex @ + dup 15 > if drop 15 then
  1009.     then f.ffld ! ;
  1010.  
  1011. : (F>TEXT) ( r --- addr count ) \ Converts fp to text
  1012. \ same as f. (below) but no printing
  1013.     unpack                     \ ==extension to FVG84
  1014.     f.ex !  f.mt d!
  1015.     set-f.ffld
  1016.     f.mt d@ f.ex @ f.ffld @ unpkround f.ex ! f.mt d!
  1017.     f.ex @ 0< if
  1018.         ffld @ dup 0< if drop 15 then f.ex @ +
  1019.         0< if 0 f.ex ! 0 0 f.mt d! set-f.ffld then
  1020.     then
  1021.     f.ex @ ffld @ 0< if abs then f.exmax @ > if
  1022.         f.mt d@ f.ex @ (f>etext)
  1023.     else
  1024.         f.ex @ 1+ 3 mod dup 0< if 3 + then f.cflg !
  1025.         f.ffld @ f.ex @ - 1- dup 0< if drop 0 then
  1026.         dup 15 > if drop 15 then f.ffld !
  1027.         0 f.ch !  16 f.div !
  1028.         f.mt @ f.mult !
  1029.         f.mt d@ dabs b->bcd f.mt d!
  1030.         f.ex @ 0< if f.-ex else f.+ex then
  1031.         f.endpoint @ 0= over dp-chars w@ = and if drop -1 f.ch +! then
  1032.         <# f.ch @ 0 do hold loop
  1033.             f.mult @ 0< if ascii - hold 1 f.ch +! then
  1034.             fld @ dup 0< if drop
  1035.             else
  1036.                 f.ch @ - 1- dup 0> if 0 do 32 hold loop else drop then
  1037.             then
  1038.         0 0 #>
  1039.     then
  1040. ;
  1041.  
  1042. : F>TEXT ( r --- addr count ) \ Converts fp to text
  1043.     fdup FPEXP 1023 > \ 00002
  1044.     IF
  1045.         fdrop " Infinity" count
  1046.     ELSE
  1047.         (f>text)
  1048.     THEN
  1049. ;
  1050.  
  1051. : F. ( r1 --- ) \ display floating-point in decimal form
  1052.     f>text type  \  uses the variable "fld" to indicate width of
  1053.     space ;      \   the display field (-1=variable width)
  1054. \   if field is not wide enough for number,
  1055. \    the number will be displayed overflowing the field
  1056. \  uses the variable "ffld" to indicate width
  1057. \   of the fractional field (places after decimal point)
  1058. \   (-1=variable width) (max 6 if r1 >= 1., 7 if < 1.)
  1059. \ ==FVG84 required  with extended features
  1060.  
  1061. : F.R ( r n1 n2 --- )  \ display fp with n1 fractional places
  1062.     fld @ >r fld !   \ right justified in a field n2 characters wide
  1063.     ffld @ >r ffld ! \ ==FVG84 optional
  1064.     f. r> ffld ! r> fld ! ;
  1065.  
  1066.  
  1067.  
  1068. : PLACES ( n --- )    \ sets default number of fractional digits
  1069.     ffld ! ;         \  when fp number is displayed by f.
  1070.     \  ==FVG84 required
  1071.  
  1072.  
  1073. variable E.LOCATION          variable MANT.LENGTH   \ all for internal use
  1074. create   E.STRING 30 allot   variable EXP.LENGTH    variable NTYPE
  1075. ascii E 256 * ascii e + constant ASCII-Ee
  1076.  
  1077.  
  1078. code cmatch? ( string cnt b --- pointer-to-matching-char-in-string | false )
  1079. \ the "byte" may be 2 bytes - e.g. ascii E 256 * ascii e +
  1080.     dsp a@+  0dr dn  move       dsp a@+  1dr dn  move
  1081.     org an   0ar an  move       1dr dn   0ar an  adda
  1082.     0dr dn   1dr dn  add        0dr dn   neg
  1083.     tos dn   2dr dn  move       8 #      2dr dn  lsr
  1084. 1 br: 0ar a@   tos dn  byte  cmp  2 beq
  1085.     0ar a@+  2dr dn  byte  cmp  2 beq
  1086.     1 #      0dr dn  addq       1 blt
  1087.     0 #      tos dn  move       3 bra
  1088. 2 br: 0dr dn   1dr dn  add        1dr dn   tos dn  move
  1089. 3 br: rts       end-code
  1090.  
  1091. \ --- BEGIN 00003 -----------
  1092. : FASTFP.NUMBER? ( addr --- r true | d true | false )
  1093. \ Converts string at addr to number
  1094. \  if it contains a decimal point,
  1095. \  it will be converted to floating.
  1096. \ Maximum input = 18 digits but only
  1097. \  7 significant digits are retained.
  1098.     0 ntype !
  1099.     dup count swap c@ ascii - = +
  1100.     20 <
  1101.     IF number?
  1102.     ELSE  drop false exit
  1103.     THEN
  1104.     IF base @ 10 = dpl @ 1+ 0> and
  1105.         IF >f 0 dpl ! 2
  1106.         ELSE 1
  1107.         THEN ntype !
  1108.     ELSE false exit
  1109.     THEN
  1110.     true
  1111. ;
  1112.  
  1113. : FLOAT.NUMBER? ( addr --- r1 true | false )
  1114. \ translate counted string to floating
  1115. \ Examples of acceptable numbers:
  1116. \  123 1.234   12.34e5  12.34E5  1.234e+5
  1117. \  2e5  e5  negatives in both mantissa
  1118. \  and exponent, but not -e5 - it must be
  1119. \  -1e5.  Max exp is +/- 308.
  1120. \  Max mantissa input = 18 digits but
  1121. \  only 15 significant digits are retained
  1122. \  ==extension to FVG84
  1123.     0 ntype ! dup count ascii-Ee cmatch?
  1124.     IF   base @ 10 = not
  1125.         IF fastfp.number?
  1126.         ELSE  e.string over c@ 1+
  1127.             dup 26 <
  1128.             IF cmove
  1129.             ELSE  2drop drop false exit \ main too long
  1130.             THEN
  1131.             e.string count ascii-Ee cmatch? e.location !
  1132.             e.location @ e.string - 1-  mant.length !
  1133.             e.string c@ mant.length @ - 1- exp.length !
  1134.             mant.length @ e.string c!
  1135.             exp.length @ e.location @ c!
  1136.             e.string count swap c@ ascii - = + 19 >
  1137.             IF  false exit
  1138.             THEN
  1139. ( dp-chars 2+ w@ >r dp-chars w@ dp-chars 2+ w! )
  1140.             e.string dup c@ 0=
  1141.             IF drop  1 0 -1 dup dpl !
  1142.             ELSE number?
  1143.             THEN
  1144.             IF >f e.location @ number?
  1145. ( r> dp-chars 2+ w! )
  1146.                 dpl @ -1 = and
  1147.                 IF drop floatexp f>r $ 100000 * + fr> f*
  1148.                     finfinity fover f= fnover f-infinity f= or fpwarn @ and
  1149.                     if ." FLOAT.NUMBER - ...warning fp infinity " abort then
  1150.                     0 dpl ! 2 ntype !
  1151.                 ELSE
  1152.                     2drop false exit \ bad exponent
  1153.                 THEN
  1154.             ELSE
  1155. ( r> dp-chars 2+ w! )
  1156.                 false exit  \ bad main number
  1157.             THEN
  1158.             true
  1159.         THEN
  1160.     ELSE fastfp.number?
  1161.     THEN
  1162. ;
  1163.  
  1164. : FASTFP.NUMBER ( addr --- r 0 | n 0 )
  1165.     fastfp.number? 0=
  1166.     IF
  1167.         0 error
  1168.     THEN
  1169. ;
  1170.  
  1171. : FLOAT.NUMBER ( addr --- r 0 | n 0 )
  1172.     float.number? 0=
  1173.     IF
  1174.         0 error
  1175.     THEN
  1176. ;
  1177.  
  1178. : FNUMBER? ( addr --- r true | false )  \ convert string to floating point
  1179.     float.number? ntype @ 2 <
  1180.     IF 2drop false
  1181.     THEN
  1182. ;
  1183.  
  1184. : FNUMBER ( addr --- r )  \ convert string to floating point
  1185.     \  ==FVG84 optional
  1186.     fnumber? 0= if 0 error then
  1187. ;
  1188. \ --- END 00003 ----------
  1189.  
  1190. : SMUDGE0123 \ smudge the names of numbers so ntype won't be circumvented
  1191.     ' 0 ' 1 ' 2 ' 3 4 0 do >name dup c@ 32 or swap c! loop
  1192.     hash-damaged on ; \ internal use
  1193.  
  1194. : UNSMUDGE0123 \ unsmudge the names of numbers so they can be found
  1195.     ' 0 ' 1 ' 2 ' 3 4 0 do >name dup c@ 223 and swap c! loop
  1196.     hash-damaged on ; \ internal use
  1197.  
  1198. : FLOAT.INTERPRET ( --- )      \ integer, decimal form, or "E" form
  1199.     ' float.number  \ decimal point indicates floating point
  1200.     is number
  1201. \  smudge0123
  1202.     open-mathlibs
  1203. ;    \ ==extension to FVG84
  1204.  
  1205. : FIX.INTERPRET ( --- )        \ put it back the old way
  1206.     ' (number)      \ ==extension to FVG84
  1207.     is number 0 ntype !
  1208. \  unsmudge0123
  1209. ;
  1210.  
  1211.  
  1212. : FASTFP.INTERPRET ( --- )     \ integer or decimal form (no "E" form)
  1213.     ' fastfp.number \ decimal point indicates floating point
  1214.     is number
  1215. \  smudge0123
  1216.     open-mathlibs ;      \ ==extension to FVG84
  1217.  
  1218.  
  1219. : FPINIT ( -- )
  1220.     open-mathlibs float.interpret 0 ntype !
  1221. ;
  1222.  
  1223. : FPTERM ( -- )
  1224.     fix.interpret close-mathlibs
  1225. ;
  1226.  
  1227. only forth definitions
  1228.  
  1229. : AUTO.INIT ( -- , start floating point if loaded)
  1230.     auto.init fpinit
  1231.     ." Floating Point Initialized!" cr
  1232. ;
  1233.  
  1234. : AUTO.TERM ( -- , term floating point if loaded 00003 )
  1235.     fpterm auto.term \ 00004
  1236. ;
  1237.  
  1238. \ Reset NUMBER vector if this code forgotten.
  1239. if.forgotten fpterm
  1240.  
  1241. close-mathlibs
  1242.  
  1243. cr ." Enter:   FPINIT  to start floating point" cr
  1244.  
  1245.